home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / html_cache.tcl.z / html_cache.tcl
Text File  |  2002-07-08  |  4KB  |  149 lines
  1. # manage the image file cache.
  2.  
  3. proc Cache_Init {} {
  4.     global cache cachesize WebTk
  5.     set max [expr 1024 * 1024 * 2]
  6.     catch {set max $cachesize(max)}
  7.     catch {unset cachesize}
  8.     set cachesize(total) 0
  9.     set cachesize(max) $max
  10.     CacheMkDir $WebTk(cache)
  11.     foreach u [array names cache] {
  12.     Cache_SetFile $u $cache($u)
  13.     }
  14. }
  15.  
  16. proc !Cache_Preferences {win} {
  17.     global cachesize WebTk imagecachesize
  18.     set current 0
  19.     catch {set current [expr $cachesize(total) / 1024]}
  20.     set max [expr $cachesize(max)/1024]
  21.     DialogEntry $win .cache "
  22. Images are cached in two ways.
  23. 1) A directory holds data between uses of WebTk.  You
  24. can choose the location and the max size of this image cache.
  25. Increasing this parameter increases disk space usage.
  26. The current size is $current Kbytes out of $max Kbytes.
  27. 2) In-memory images are retained after you leave a page.
  28. You can control how many images are retained.  Increasing
  29. this parameter increases memory use.  A setting of zero 
  30. minimizes memory use.
  31. " CachePrefOK [list [list Directory $WebTk(cache)] \
  32.             [list "Max Kbytes" $max] \
  33.             [list "Image Count" $imagecachesize] \
  34.         ]
  35. }
  36. proc !CachePrefOK {list} {
  37.     global cachesize WebTk imagecachesize
  38.     array set t $list
  39.     set WebTk(cache) $t(Directory)
  40.     catch {set cachesize(max) [expr $t(Max\ Kbytes) * 1024]}
  41.     catch {set imagecachesize [expr $t(Image\ Count)]}
  42.     if {$cachesize(max) < 0} {
  43.     set cachesize(max) 0
  44.     }
  45.     if {$imagecachesize < 0} {
  46.     set imagecachesize 0    ;# Enforced when a new page is displayed
  47.     }
  48.     while {$cachesize(total) > $cachesize(max)} {
  49.     CacheDeleteOne
  50.     }
  51.     CheckPoint
  52. }
  53. proc CachePrefTrace {} {
  54.     global cachesize WebTk imagecachesize
  55.     if {$cachesize(max) < 0} {
  56.     set cachesize(max) 0
  57.     }
  58.     if {$imagecachesize < 0} {
  59.     set imagecachesize 0    ;# Enforced when a new page is displayed
  60.     }
  61.     while {$cachesize(total) > $cachesize(max)} {
  62.     CacheDeleteOne
  63.     }
  64. }
  65. proc Cache_Cleanup {} {
  66.     global cache
  67.  
  68.     foreach url [array names cache] {
  69.     File_Delete $cache($url)
  70.     }
  71. }
  72.  
  73. proc Cache_NewFile {url} {
  74.     global cache WebTk
  75.     if ![info exists cache($url)] {
  76.     set hash 8251
  77.     foreach c [split $url {}] {
  78.         scan $c %c x
  79.         set hash [expr {($hash << 5) ^ $x}]
  80.     }
  81.     set hash [expr {$hash & 0x7FFFFFFF}]
  82.     return [file join $WebTk(cache) [format %x $hash][file extension $url]]
  83.     } else {
  84.     return $cache($url)
  85.     }
  86. }
  87.  
  88. # If a name is in the cache, but no cache size, then the
  89. # cache has not been fully loaded.
  90.  
  91. proc Cache_GetFile {url} {
  92.     global cache
  93.     if [info exists cache($url)] {
  94.     return $cache($url)
  95.     } else {
  96.     return {}
  97.     }
  98. }
  99.  
  100. proc Cache_SetFile {url file} {
  101.     global cache cachesize
  102.     set old 0
  103.     catch {set old $cachesize($file)}
  104.     if [catch {
  105.     # File may no longer exist
  106.     set cachesize($file) [file size $file]
  107.     incr cachesize(total) [expr $cachesize($file)-$old]
  108.     set cache($url) $file
  109.     Exmh_Debug "cache $file $url"
  110.     while {$cachesize(total) > $cachesize(max)} {
  111.         CacheDeleteOne
  112.     }
  113.     }] {
  114.     catch {unset cachesize($file)}
  115.     catch {unset cache($url)}
  116.     incr cachesize(total) -$old
  117.     if {$cachesize(total) < 0} {
  118.         set cachesize(total) 0
  119.     }
  120.     }
  121. }
  122. proc CacheDeleteOne {} {
  123.     global cache cachesize
  124.     set urls [array names cache]    ;# Random hash
  125.     set url [lindex $urls 0]
  126.     set file $cache($url)
  127.     File_Delete $file
  128.     catch {unset cache($url)}
  129.     catch {incr cachesize(total) -$cachesize($file)}
  130.     catch {unset cachesize($file)}
  131.     if {[llength $urls] <= 1} {
  132.     set cachesize(total) 0
  133.     }
  134. }
  135. proc CacheMkDir {dir} {
  136.     global tk_version
  137.     if {$tk_version < 4.2} {
  138.     set tail [file tail $dir]
  139.     set dir [file dirname $dir]
  140.     set dir [glob -nocomplain $dir]/$tail
  141.     catch {mkdir $dir}
  142.     catch {exec mkdir $dir}
  143.     } else {
  144.     file mkdir $dir
  145.     }
  146. }
  147. Cache_Init
  148.  
  149.